The PC-SIG Library 10/The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso/PC_SIGCD/06/8/DISK0685.ZIP/FORTH.ARC/FILES.SCR

Text File | 1983-07-30 | 20KB | 1 lines

                                                                                                                                                         -+-                                                                                                                         MS-DOS  File                                              -+                    +-                                               Interface                                                                                                                          -+-                                                                                                                                                                                                                                                                                                                                                                      Note: these screens must be loaded from a FORTH disk!                                                                         ( strings: ", ["] )                                                                                                             : "    ( accept text delimited by " to PAD with count )              34 WORD  PAD C/L BLANKS                                         HERE PAD HERE C@ 1+ CMOVE ;                                                                                                : (")  ( moves text in definition to PAD )                           PAD C/L BLANKS                                                  R PAD R C@ 1+ R> OVER + >R  CMOVE ;                                                                                        : ["   ( as ", but get text in definition, then to PAD at exec )     COMPILE (")                                                     34 WORD  HERE C@ 1+ ALLOT ;  IMMEDIATE                     -->                                                                                                                                                                                             ( error handling: ABORT" )                                                                                                      : (AB")  PAD COUNT TYPE SP! QUIT ;                                                                                              : ABORT"  ( f -- ;abort execution and type a message )                    ( if f is TRUE )                                           [COMPILE] IF [COMPILE] ["                                        COMPILE  (AB")                                                 [COMPILE] THEN ;  IMMEDIATE                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ( MS-DOS file interface: support words, FNAME )                                                                                 : @FCB 2+ ;      (  fd -- FCB ; advances fd to start of FCB)    : @FSIZE  16 + ; ( FCB -- FCB.SIZE ; returns addr of size field)                                                                : FNAME  ( addr mode -- afn ; parse word at PAD as a filename )          ( afn is true if filename is ambiguous )                        ( Mode determines defaults for MS-DOS function 29H)             ( Parsed file name, drive+11 bytes, is left at addr)       PAD 1+ SWAP (FNAME)         ( -- addr' afn )                    SWAP PAD 1+ - PAD C@ = 0=                                       HEX 4000 PAD !              ( mark PAD so the name )            DECIMAL                     ( can't be used accidentally  )     ABORT" ? Illegal filename" ;                                -->                                                                                                                             ( MS-DOS file interface: CONSTANTS and error checking )         37 CONSTANT FCBSIZE                                                ( constants defining attributes in fd : )                    1  CONSTANT RD       2 CONSTANT WRT      4 CONSTANT OPN         8  CONSTANT SCRNS                                                  ( mode constants for use with FNAME, DF=DeFault )            2  CONSTANT DF-DRIVE 4 CONSTANT DF-NAME  8 CONSTANT DF-EXT                                                                      :  ?READ    @ RD    AND 0= ABORT" ? file is for output"     ;   :  ?WRITE   @ WRT   AND 0= ABORT" ? file is for input"      ;   :  ?SCREENS @ SCRNS AND 0= ABORT" ? isn't a screen file"    ;   :  ?CHAR    @ SCRNS AND    ABORT" ? isn't a character file" ;   :  ?OPEN    @ OPN   AND 0= ABORT" ? file isn't open"        ;   :  ?SHUT    @ OPN   AND    ABORT" ? file is in use"         ;   -->                                                                                                                             ( MS-DOS file interface: FILE, IS" )                                                                                            : FILE  ( x -- ; define a file of type x )                           <BUILDS                                                            ,              ( fd := file type )                              FCBSIZE ALLOT  ( room for FCB )                               DOES> ;          ( leave fd )                                                                                             : FILE>   RD       FILE ; ( read only file defining word )      : >FILE   WRT      FILE ; ( write only file... )                : >FILE>  RD WRT + FILE ; ( read/write file... )                                                                                : /IS"    ( fd -- afn ; accept input stream as filename )            @FCB " 0 FNAME  ;                                          -->                                                                                                                             ( MS-DOS file interface: /SETSIZE, /SETREC )                                                                                    : /SETSIZE  ( n fd -- ; sets record size of fd to n )                @FCB 14 + ! ;                                                                                                              : /SETREC   ( n fd -- ; set random record to n )                     0 ROT ROT @FCB 33 + 2! ; ( FORTH only uses 16 bits )                                                                       -->                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( MS-DOS file interface: /CREATE /OPEN /CLOSE )                 : /CREATE  ( fd -- ; create and open fd )                            DUP ?SHUT  DUP ?WRITE                                           DUP @FCB 12 + FCBSIZE 12 - ERASE                                DUP @FCB (CREATE) ABORT" ? Can't create file"                   OPN TOGGLE ;                                               : /OPEN   ( fd -- ; open fd )                                        DUP ?SHUT                                                       DUP @FCB 12 + FCBSIZE 12 - ERASE                                DUP @FCB (OPEN) ABORT" ? File doesn't exist"                    OPN TOGGLE ;                                               : /CLOSE  ( fd -- ; close fd )                                       DUP @FCB (CLOSE)                                                ABORT" ? Can't close file, did you change disks?"               DUP @ -1 OPN - AND SWAP ! ;   -->                                                                                          ( MS-DOS file interface: /READ /WRITE )                                                                                         : /READ   ( fd addr n -- f ; READ n bytes from file fd to addr )     ROT DUP ?READ  DUP ?OPEN  DUP ?CHAR                             SWAP OVER ( addr fd n fd ) /SETSIZE                             @FCB SWAP (READ) ;                                                                                                         : /WRITE  ( addr n fd -- f ; WRITE n bytes from addr to fd )         DUP ?WRITE   DUP ?OPEN   DUP ?CHAR                              SWAP OVER /SETSIZE                                              @FCB SWAP (WRITE) ;                                        -->                                                             ( NOTE: n should not be varied between reads/writes ! )         ( The file pointer maintained by MSDOS is in terms of the )     ( record size being used, and changing the record size without) ( adjusting the pointer causes problems... )                    ( MS-DOS file interface: /GETC /PUTC )                          0 VARIABLE [C]                                                                                                                  : /GETC  ( fd -- c ; get char c from file fd )                       [C] 1 /READ IF 0 ELSE [C] @ THEN ;                                                                                         : /PUTC   ( c fd -- f ; write c to fd, f is TRUE on error )          SWAP [C] ! [C] 1 ROT /WRITE ;                                                                                              -->                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( MS-DOS file interface: /BLKS )                                : /BLKS   ( fd -- n ; leaves no. B/BUF sized blocks in file. )            ( ABORTS if <filesize>/<B/BUF> is not an integer )         DUP ?OPEN                                                       DUP @FCB @FSIZE 2@ SWAP B/BUF M/ SWAP                           IF ( rem<>0 ) DROP /CLOSE ( close the file )                       ABORT" ? File isn't a screen file"                           ELSE SWAP DROP THEN ;                                      -->                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( MS-DOS file interface: SCREENS, /BLOCK-READ, WRITE )                                                                          RD WRT + SCRNS +    FILE  SCREENS ( fd for screens )                                                                            ( The following functions do no error checking because BLOCK )  ( becomes really  fouled up if it ABORTS  before finishing ! )                                                                  : /BLOCK-READ   ( addr blk -- ; read BLK from SCREENS )              RECORD !  DTA !                                                 SCREENS @FCB 1 (FBLKRD) DISK-ERROR ! ;                                                                                     : /BLOCK-WRITE  ( addr blk -- ; write BLK to SCREENS )               RECORD !  DTA !                                                 SCREENS @FCB 1 (FBLKWRT) DISK-ERROR ! ;                    -->                                                                                                                             ( MS-DOS file utilities: FCB display primitives )                                                                               : .DRIVE  ( addr -- ; print addr as drive A-Z )                      C@ 64 + EMIT 58 EMIT ;                                     : .FNAME  ( addr -- ; print filename at addr )                       DUP 8 TYPE 46 EMIT 8 + 3 TYPE SPACE ;                      : .FSIZE  ( addr -- ; print size )                                   2@ SWAP 10 D.R 2 SPACES ;                                                                                                  : 2DIGS 0 <# # # #> TYPE ;                                      : .MO   @ 480 AND 32 / 2DIGS 45 EMIT ;                          : .DAY  @ 31 AND 2DIGS 45 EMIT ;                                : .YR   1+ C@ 2 / 1980 + 0 <# # # # # #> TYPE 2 SPACES ;                                                                        -->                                                                                                                             ( MS-DOS file utilities: fd display /? )                        : .DATE  ( addr -- ; print date stamp )                             DUP .MO DUP .DAY .YR ;                                                                                                      : .HR   1+ C@ 248 AND 8 / 2 .R 58 EMIT ;                        : .MIN  @ 2016 AND 32 / 2DIGS 2 SPACES ;                        : .TIME DUP .HR .MIN ; ( addr -- ;print time stamp )            : /?  ( fd -- ; print status of file ) CR                            DUP @FCB DUP    .DRIVE DUP 1+ .FNAME >R                         DUP @ RD AND    IF 114 ELSE 45 THEN EMIT SPACE                  DUP @ WRT AND   IF 119 ELSE 45 THEN EMIT SPACE                  DUP @ SCRNS AND IF 115 ELSE 99 THEN EMIT SPACE                      @ OPN AND   IF R 16 + .FSIZE  R 20 + .DATE                  R> 22 + .TIME ELSE R> DROP THEN 2 SPACES ;                 -->                                                                                                                             ( MS-DOS file utilities: DIR )                                                                                                  : .DIR   ( addr -- ; print directory entry at addr )                 DUP >R .DRIVE R 1+ .FNAME R 29 + .FSIZE                              R 25 + .DATE R> 23 + .TIME SPACE ;                    -->                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( MS-DOS file interface: -SET, EOF )                            : -SET  ( addr blk -- ;inform user about disk state )                1 DISK-ERROR ! ( force BLOCK to abort )                         CR ." Specify disk access mode: "                               CR ." use SWITCH or USING" 34 EMIT 46 EMIT                      CR ;                                                                                                                       : EOF   ( -- ;quit using screen file, but don't use FORTH disk)      FLUSH SCREENS DUP ?OPEN DUP /BLKS  ( check # blocks )           SWAP /CLOSE IF ( # blocks >0 )                                    SCREENS @FCB PAD ?FIRST ABORT" File not in directory!"          PAD .DIR  ( show the directory entry )                        ELSE                                                              SCREENS @FCB ."  Erasing empty file..." FDEL                    IF ." couldn't erase " THEN                                   THEN  ' -SET CFA DUP @BLKRD ! @BLKWRT ! ; -->              ( MS-DOS file interface: SWITCH )                                                                                               : SWITCH   ( -- ;switch to FORTH disk )                              SCREENS @ OPN AND IF ( open ) EOF ( close SCREENS ) THEN        ' BLKRD CFA @BLKRD !  ' BLKWRT CFA @BLKWRT !                 CR CR ." WARNING: Replace MS-DOS disks with FORTH disks  " ;                                                                  : BYE  ( -- ;leave FORTH, make sure SCREENS are closed )             SCREENS @ OPN AND IF ( open ) EOF ( close SCREENS ) THEN        BYE ;                                                                                                                      : A:   ( -- ;select drive A as the default drive )                   0 DISK DROP ;                                                                                                              : B:   ( -- ;select drive B as the default drive )                   1 DISK DROP ; -->                                          ( MS-DOS file interface: USING" )                                                                                               : USING"   ( --;set up to use screen file. )                               ( usage is USING" filename" )                            SCREENS ?SHUT   ( only one file at a time! )                    [" .SCR" SCREENS @FCB 0 FNAME DROP ( set default = .SCR )       SCREENS @FCB "  ( get filename from terminal )                  DF-EXT FNAME    ( assign name to SCREENS using default ext )    ABORT" no */? allowed"                                          SCREENS @FCB (OPEN)              ( try to open it... )          IF ( non-existent ) SCREENS /CREATE                             ELSE SCREENS OPN TOGGLE THEN    ( set open attribute )          SCREENS /BLKS    ( check record size, leave # blocks )          0 WARNING !      ( probably can't find error mesages )          0 SCREENS /SETREC   ( initialize random record field )          B/BUF SCREENS /SETSIZE      ( transfer whole buffers ) -->  ( MS-DOS file interface: USING", cont. EXTEND )                     -DUP IF ( non-empty file )                                        ." last block in " SCREENS @FCB DUP .DRIVE                      1+ DUP 8 -TRAILING TYPE            ( print file name )          46 EMIT 8 + 3 -TRAILING TYPE       ( print ext )                ."  is " 1- U. ( print filename and number of blocks )        ELSE ." empty file " THEN                                       ' /BLOCK-READ CFA @BLKRD !      ( read from file now )          ' /BLOCK-WRITE CFA @BLKWRT !    ( write to file now )           EMPTY-BUFFERS ;                 ( don't mix buffers )                                                                       : EXTEND  ( n -- ;allocate n additional blocks to SCREENS )          SCREENS ?OPEN ( must be using SCREENS )                         SCREENS /BLKS + 1- BUFFER  ( assign a buffer to last block)     UPDATE SAVE-BUFFERS DROP ; ( force it to disk )            -->                                                             ( MS-DOS file interface: LOAD" , INDEX" )                                                                                       : LOAD"  ( -- ;load a screen file, can't be nested )                 USING" ( get file name and open file )                          0 15 0 DO I OVER CR .LINE  ( list screen 0 : title screen )     LOOP DROP  CR                                                   1 LOAD  ( start loading at screen 1 )                           EOF  ( quit after LOAD ) ;                                 ;S